home *** CD-ROM | disk | FTP | other *** search
/ infoROM 17,000 Product Descriptions for Business / infoROM Product Descriptions for Business - ESX Interactive.ISO / argdemos / nexsys / structur.atl < prev    next >
Encoding:
Text File  |  1993-06-21  |  4.7 KB  |  153 lines
  1. \
  2. \  STRUCTURE.ATL
  3. \
  4. \  Copyright (C) 1993 by Derrick Oswald
  5. \
  6. \  Derrick Oswald
  7. \  Nexsys Consulting Inc.
  8. \  44 Douglas Drive
  9. \  Ayr, Ontario
  10. \  N0B 1E0
  11. \  (519) 632-8243
  12. \  (519) 632-8244 FAX
  13.  
  14. \  Description:
  15. \       Allows aggregates of data to be described as structures. General-
  16. \       ization of structures in traditional programming languages. Allows
  17. \       definition, initialization and action part. Basic object based
  18. \       action may be defined in a style similar to the "does" section of
  19. \       a creating word.
  20. \
  21.  
  22. .( "\nLoading Structures definitions..."
  23.  
  24. \ field - creates a field definition at compile time
  25. \         at run time adds the field offset to the structure address
  26. : field ( offset -> )
  27.     constant
  28.   does>
  29.     @ + ;
  30.  
  31. \ size of compiled item
  32. 4 constant cell
  33.  
  34. 0 field ->StructureSize ( struct.type -- addr)
  35. cell field ->Initiate ( struct.type -- addr)
  36.  
  37. : as ( -- struct.type)  
  38.   ' >body                               ( Quote next symbol and access body)
  39.   \ this should be
  40.   \   [compile] literal                 ( If compiling generate a literal)
  41.   \ but atlas complains if compiler words are used outside a : definition
  42.   state @ if
  43.     compile (lit) ,
  44.   then
  45. ; immediate
  46.  
  47. : this ( -- addr)
  48.   last >body                            ( Access the body of the last symbol)
  49. ;
  50.  
  51. : initiate ( addr struct.type -- )  
  52.   ->Initiate @ ?dup                     ( Access initiate. code pointer)
  53.   if >r else drop then                  ( If available perform initialization)
  54. ;
  55.  
  56. \ make-struct - reserve memory for a structure and initialize
  57. : make-struct ( struct.type -- addr)
  58.   here dup >r                           ( Save pointer to instance)
  59.   over ->StructureSize @ allot          ( Access size and allocate memory)
  60.   swap initiate r>                      ( Perform initialization)
  61. ; 
  62.  
  63. \ ?compile - compile or execute next threaded word depending on state
  64. : ?compile ( -- )
  65.   state @ if
  66.     r> dup , 4 + >r
  67.   then
  68. ;
  69.  
  70. \ new-struct - create structure of following type
  71. : new-struct ( -- addr)
  72.   [compile] as                          ( Take the next symbol, "as")
  73.   ?compile make-struct                  ( And "make" an instance)
  74. ; immediate
  75.  
  76. \ sizeof - return the size of a structure
  77. : sizeof ( -- num)
  78.   ' >body ->StructureSize @             ( Access size of structure)
  79.   \ this should be
  80.   \   [compile] literal                 ( And make literal if compiling)
  81.   \ but atlas complains if compiler words are used outside a : definition
  82.   state @ if
  83.     compile (lit) ,
  84.   then
  85. ; immediate
  86.  
  87. \ assign - set structure data
  88. : assign ( a b -- )  
  89.   [compile] sizeof ?compile cmove       ( Access size and assign instance)
  90. ; immediate
  91.  
  92. \ .( "\nnot-equal"
  93. \ : not-equal ( a b -- bool)
  94. \  [compile] sizeof ?compile -match     ( Access size and match the blocks)
  95. \ ; immediate
  96.  
  97. \ struct.type - lead in word for structure definition
  98. : struct.type ( -- struct.type offset0)  
  99.   create
  100.   here 4 + \ add 4 because ATLAS moves the word when does> encountered
  101.   0 0 , 0 ,                             ( Allocate initial struct information)
  102. does> ( struct.type -- )
  103.   create make-struct drop               ( Create a new instance)
  104. ;
  105.  
  106. : bytes ( offset1 n -- offset2)
  107.   over field +
  108. \  over dup                              ( Check for zero offset)
  109. \  if field +                            ( Create an access field of "n" bytes)
  110. \  else
  111. \    create , + immediate                ( Create an efficient field)
  112. \    does> ( field -- )
  113. \      drop                              ( Does nothing at runtime )
  114. \  then
  115. ;
  116.  
  117. : align ( offset1 -- offset2)  
  118.   dup 1 and +                           ( Align field offset to even address)
  119. ;
  120.  
  121. : struct.field ( bytes -- )  
  122.   create , 0 ,                          ( Create a predefined field type)
  123. does> ( struct.field -- )
  124.   @ bytes                               ( At run-time create field names)
  125. ; 
  126.  
  127. : struct ( -- )  
  128.   [compile] sizeof bytes                ( Create a structure sized field name)
  129. ;
  130.  
  131. ( Initial set of field names)
  132. 1 struct.field byte ( -- )
  133. 2 struct.field word ( -- )
  134. 4 struct.field long ( -- )
  135. 4 struct.field ptr  ( -- )
  136. 4 struct.field enum ( -- )
  137.  
  138. : struct.init ( struct.type offset3 -- )
  139.   align over ->StructureSize !          ( Assign size of structure type)
  140.   here swap ->Initiate ]                ( And pointer to initialization code)
  141. ;
  142.  
  143. : struct.does ( -- ) 
  144.   [compile] does>                       ( Do what does-does)
  145. ; immediate
  146.  
  147. : struct.end ( [] or [struct.type offset3] -- )  
  148.   state @                               ( Check compilation status)
  149.   if ['] EXIT , [COMPILE] [             ( If compiling then end definition)
  150.   else swap ->StructureSize ! then      ( Else assign size of structure type)
  151. ; immediate
  152.  
  153. .( "\nLoaded.\n"